home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / specials.c < prev    next >
C/C++ Source or Header  |  1993-06-14  |  19KB  |  768 lines
  1. /* ******************************************************************** */
  2. /* specials.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Language special forms (NOT toplevel forms)                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: specials.c,v 2.1 93/01/17 17:58:13 pab Exp $
  9.  *
  10.  * $Log:    specials.c,v $
  11.  * Revision 2.1  93/01/17  17:58:13  pab
  12.  * Deleted Env reference
  13.  * 
  14.  * Revision 1.17  1992/11/26  16:05:02  pab
  15.  * Env removal, table changes, etc
  16.  *
  17.  * Revision 1.16  1992/06/12  00:00:55  pab
  18.  * fixed tagbody
  19.  *
  20.  * Revision 1.15  1992/05/28  11:28:26  pab
  21.  * GC protect
  22.  *
  23.  * Revision 1.14  1992/05/19  11:26:37  pab
  24.  * tagbody (blech blech) fixed
  25.  *
  26.  * Revision 1.13  1992/04/30  19:42:18  pab
  27.  * fixed setq(!)
  28.  *
  29.  * Revision 1.12  1992/04/27  21:59:49  pab
  30.  * fixed env stacks
  31.  *
  32.  * Revision 1.11  1992/04/26  21:07:07  pab
  33.  * 'lost ' handler code
  34.  *
  35.  * Revision 1.10  1992/03/07  21:45:16  pab
  36.  * initial continuation changes
  37.  *
  38.  * Revision 1.9  1992/02/10  16:41:09  pab
  39.  * fixed dynamics properly
  40.  *
  41.  * Revision 1.8  1992/01/29  13:47:28  pab
  42.  * bindig fix, gc fix in dynamic let
  43.  *
  44.  * Revision 1.7  1992/01/09  22:29:05  pab
  45.  * Fixed for low tag ints
  46.  *
  47.  * Revision 1.6  1992/01/07  22:13:27  pab
  48.  * *** empty log message ***
  49.  *
  50.  * Revision 1.5  1992/01/05  22:48:20  pab
  51.  * Minor bug fixes, plus BSD version
  52.  *
  53.  * Revision 1.4  1991/12/22  15:14:34  pab
  54.  * Xmas revision
  55.  *
  56.  * Revision 1.3  1991/09/22  19:14:40  pab
  57.  * Fixed obvious bugs
  58.  *
  59.  * Revision 1.2  1991/09/11  12:07:40  pab
  60.  * 11/9/91 First Alpha release of modified system
  61.  *
  62.  * Revision 1.1  1991/08/12  16:50:00  pab
  63.  * Initial revision
  64.  *
  65.  * Revision 1.4  1991/02/13  18:28:55  kjp
  66.  * Pass.
  67.  *
  68.  */
  69.  
  70. /*
  71.  * Change Log:
  72.  *   Version 1, March 1990 (Compiler rationalisation)
  73.  *     New fully working let/cc and unwind-protect - 
  74.  *       all stacks dealt with and dead continuations killed (KJP)
  75.  */
  76.  
  77. #include "defs.h"
  78. #include "structs.h"
  79. #include "funcalls.h"
  80. #include "error.h"
  81. #include "global.h"
  82.  
  83. #include "slots.h"
  84. #include "garbage.h"
  85.  
  86. #include "symboot.h"
  87. #include "modules.h"
  88. #include "root.h"
  89. #include "allocate.h"
  90. #include "specials.h"
  91. #include "toplevel.h"
  92. #include "state.h"
  93. #include "streams.h"
  94.  
  95. /*
  96.  
  97.  * We're talking just the non-toplevel restricted special forms here
  98.  * like lambda, setq, and if - the ones always available.
  99.  
  100.  */
  101.  
  102. LispObject special_table;
  103.  
  104. LispObject my_make_special(LispObject *stacktop,
  105.                char *name, LispObject (*func)())
  106. {
  107.   LispObject ans,tmp;
  108.   
  109.   ans = (LispObject) get_symbol(stacktop,name);
  110.   SYM_CACHE_INIT(ans);
  111.   STACK_TMP(ans);
  112.   tmp = (LispObject) allocate_special(stacktop,ans,func);
  113.   UNSTACK_TMP(ans);
  114.   STACK_TMP(tmp);
  115.   EUCALL_3(Fn_table_ref_setter,special_table,ans,tmp);
  116.   UNSTACK_TMP(tmp);
  117.   return tmp;
  118. }
  119.  
  120. EUFUN_1( Fn_special_form_p, name)
  121. {
  122.   return(EUCALL_2(Fn_table_ref,special_table,name));
  123. }
  124. EUFUN_CLOSE
  125.  
  126. LispObject special_lambda;
  127. EUFUN_3( Sf_lambda, mod, env, forms)
  128. {
  129.   LispObject bvl,myforms;
  130.   LispObject ans,walker;
  131.   int i;
  132.  
  133.   if (forms == nil) {
  134.     CallError(stacktop,"lambda: illegal empty lambda form",nil,NONCONTINUABLE);
  135.   }
  136.  
  137.   myforms = forms;
  138.  
  139.   bvl = CAR(myforms); myforms = CDR(myforms);
  140.   STACK_TMP(bvl); STACK_TMP(myforms);
  141.  
  142.   walker = bvl; i = 0;
  143.   while (is_cons(walker)) {
  144.     walker = CDR(walker);
  145.     ++i;
  146.   }
  147.  
  148.   if (walker != nil)  /* improper lambda list */
  149.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  150.   else
  151.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  152.  
  153.   UNSTACK_TMP(myforms); UNSTACK_TMP(bvl);
  154.   ans->I_FUNCTION.bvl  = bvl;
  155.   ans->I_FUNCTION.body = myforms;
  156.   ans->I_FUNCTION.home = ARG_0(stackbase);
  157.  
  158.   return ans;
  159. }
  160. EUFUN_CLOSE
  161.  
  162. LispObject special_macro_lambda;
  163. EUFUN_3(Sf_mlambda, mod, env, forms)
  164. {
  165.   LispObject bvl;
  166.   LispObject ans,walker;
  167.   int i;
  168.  
  169.   if (forms == nil) {
  170.     CallError(stacktop,
  171.           "macro-lambda: illegal empty macro-lambda form",nil,NONCONTINUABLE);
  172.   }
  173.  
  174.   bvl = CAR(forms); forms = CDR(forms);
  175.   ARG_2(stackbase)=forms;
  176.   walker = bvl; i = 0;
  177.   while (is_cons(walker)) {
  178.     walker = CDR(walker);
  179.     ++i;
  180.   }
  181.   STACK_TMP(bvl);
  182.   if (walker != nil)  /* improper lambda list */
  183.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  184.   else
  185.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  186.  
  187.   UNSTACK_TMP(bvl);
  188.   lval_typeof(ans) = TYPE_I_MACRO;
  189.   ans->I_MACRO.bvl  = bvl;
  190.   ans->I_MACRO.body = ARG_2(stackbase)/*forms*/;
  191.   ans->I_MACRO.home = ARG_0(stackbase)/*mod*/;
  192.  
  193.   return ans;
  194. }
  195. EUFUN_CLOSE
  196.  
  197. LispObject special_setq;
  198. EUFUN_3( Sf_setq,  mod, env, forms)
  199. {
  200.   LispObject id;
  201.  
  202.   if (forms == nil) 
  203.     CallError(stacktop,"setq: illegal empty setq form",nil,NONCONTINUABLE);
  204.  
  205.   id = CAR(forms); forms = CDR(forms);
  206.  
  207.   if (!is_symbol(id))
  208.     CallError(stacktop,"setq: non-symbolic id",id,NONCONTINUABLE);
  209.  
  210.   if (CDR(forms)!=nil) 
  211.     CallError(stacktop,"setq: additional setq forms",nil,NONCONTINUABLE);
  212.  
  213.   while (reserved_symbol_p(id)) {
  214.     id = CallError(stacktop,"setq: reserved symbol",id,CONTINUABLE);
  215.   }
  216.   STACK_TMP(id);
  217.   forms = EUCALL_3(module_eval,mod,env,CAR(forms));
  218.   UNSTACK_TMP(id);
  219.   STACK_TMP(forms);
  220.   STACK_TMP(id);
  221.   env=ARG_1(stackbase);
  222.   while (env != NULL) 
  223.     {
  224.       if (env->ENV.variable == id)
  225.     {
  226.       if (typeof(env)!=TYPE_FIXENV) 
  227.         return (env->ENV.value = forms);
  228.       
  229.       /* Used to be Fn_equal */
  230.       if (forms!=env->ENV.value)
  231.         CallError(stacktop,"setq: immutable binding",id,NONCONTINUABLE);
  232.       return forms;
  233.     }
  234.       env = (LispObject) env->ENV.next;
  235.     }
  236.   UNSTACK_TMP(id);
  237.   UNSTACK_TMP(forms);
  238.   /* Going for the module environment */
  239.   mod=ARG_0(stackbase);
  240.   STACK_TMP(forms);
  241.   (void) EUCALL_3(module_set,mod,id,forms); /* In the module handler */
  242.   UNSTACK_TMP(forms);
  243.   return(forms);
  244.  
  245. }
  246. EUFUN_CLOSE
  247.  
  248. LispObject special_progn;
  249. EUFUN_3( Sf_progn, mod, env, forms)
  250. {
  251.   LispObject ret;
  252.  
  253.   if (!is_cons(forms))
  254.     CallError(stacktop,"progn: bad forms",forms,NONCONTINUABLE);
  255.  
  256.   ret = nil; /* Null case return value */
  257.  
  258.   while (is_cons(forms)) {
  259.     STACK_TMP(CDR(forms));
  260.     ret = EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(forms));
  261.     UNSTACK_TMP(forms);
  262.   }
  263.  
  264.   return(ret);
  265. }
  266. EUFUN_CLOSE
  267.  
  268. LispObject special_if;
  269. EUFUN_3( Sf_if, mod, env, forms)
  270. {
  271.   LispObject pred,alt1,alt2;
  272.   LispObject debug;
  273.  
  274.   debug = forms;
  275.  
  276.   if (!is_cons(forms))
  277.     CallError(stacktop,"if: missing predicate",forms,NONCONTINUABLE);
  278.  
  279.   pred = CAR(forms); forms = CDR(forms);
  280.  
  281.   if (!is_cons(forms))
  282.     CallError(stacktop,"if: missing consequence",debug,NONCONTINUABLE);
  283.  
  284.   alt1 = CAR(forms); forms = CDR(forms);
  285.  
  286.   if (!is_cons(forms))
  287.     CallError(stacktop,"if: missing alternative",debug,NONCONTINUABLE);
  288.  
  289.   alt2 = CAR(forms); forms = CDR(forms);
  290.  
  291.   if (forms != nil)
  292.     CallError(stacktop,"if: extraneous forms",forms,NONCONTINUABLE);
  293.   
  294.   STACK_TMP(alt1);
  295.   STACK_TMP(alt2);
  296.   if (EUCALL_3(module_eval,mod,env,pred) != nil) {
  297.     UNSTACK_TMP(alt1); UNSTACK_TMP(alt1);
  298.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt1));
  299.   }
  300.   else {
  301.     UNSTACK_TMP(alt2);
  302.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt2));
  303.   }
  304. }
  305. EUFUN_CLOSE
  306.  
  307.  
  308. /*
  309.  
  310.  * Dynamics...
  311.  
  312.  */
  313.  
  314. LispObject special_dynamic_setq;
  315. EUFUN_3( Sf_dynamic_setq, mod, env, forms)
  316. {
  317.   LispObject id,form;
  318.   LispObject walker;
  319.  
  320.   if (!is_cons(forms))
  321.     CallError(stacktop,"dynamic-setq: missing symbol",forms,NONCONTINUABLE);
  322.  
  323.   id = CAR(forms); forms = CDR(forms);
  324.  
  325.   if (!is_symbol(id))
  326.     CallError(stacktop,"dynamic-setq: non-symbolic reference",id,NONCONTINUABLE);
  327.  
  328.   if (!is_cons(forms)) 
  329.     CallError(stacktop,"dynamic-setq: missing value form",forms,NONCONTINUABLE);
  330.  
  331.   form = CAR(forms); forms = CDR(forms);
  332.  
  333.   if (forms != nil)
  334.     CallError(stacktop,"dynamic-setq: extraneous forms",forms,NONCONTINUABLE);
  335.  
  336.   walker = DYNAMIC_ENV();
  337.  
  338.   while (walker != NULL) {
  339.     if (walker->ENV.variable == id)
  340.       {
  341.     STACK_TMP(walker);
  342.     form = EUCALL_3(module_eval,mod,env,form);
  343.     UNSTACK_TMP(walker);
  344.     return((walker->ENV.value = form));
  345.       }
  346.     walker = walker->ENV.next;
  347.   }
  348.  
  349.   if (id->SYMBOL.gvalue == NULL) {
  350.     print_string(stacktop,StdErr(),"****Illegal assignment to undeclared variable: ");
  351.     EUCALL_2(Fn_print,id,StdErr());
  352.     print_string(stacktop,StdErr(),"****Implicit defvar used\n");
  353.   }
  354.   STACK_TMP(id);
  355.   form = EUCALL_3(module_eval,mod,env,form);
  356.   UNSTACK_TMP(id);
  357.   return((id->SYMBOL.gvalue = form));
  358. }
  359. EUFUN_CLOSE
  360.  
  361. EUFUN_2( Fn_dynamic_setq, id, form)
  362. {
  363.   LispObject walker;
  364.  
  365.   if (!is_symbol(id))
  366.     CallError(stacktop,"(setter symbol-dynamic-value): non-symbolic reference",id,NONCONTINUABLE);
  367.  
  368.   walker = DYNAMIC_ENV();
  369.  
  370.   while (walker != NULL) {
  371.     if (walker->ENV.variable == id) return((walker->ENV.value = form));
  372.     walker = walker->ENV.next;
  373.   }
  374.  
  375.   if (id->SYMBOL.gvalue == NULL) {
  376.     print_string(stacktop,StdErr(),"****Illegal assignment to undeclared variable: ");
  377.     EUCALL_2(Fn_print,id,StdErr());
  378.     print_string(stacktop,StdErr(),"****Implicit defvar used\n");
  379.   }
  380.  
  381.   return((id->SYMBOL.gvalue = form));
  382. }
  383. EUFUN_CLOSE
  384.  
  385. LispObject special_dynamic_set;
  386. EUFUN_3( Sf_dynamic_set, mod, env, forms)
  387. {
  388.   LispObject id,form;
  389.   LispObject walker;
  390.  
  391.   if (!is_cons(forms))
  392.     CallError(stacktop,"dynamic-set: missing symbol",forms,NONCONTINUABLE);
  393.  
  394.   id = CAR(forms); forms = CDR(forms);
  395.  
  396.   id = EUCALL_3(module_eval,mod,env,id);
  397.  
  398.   if (!is_symbol(id))
  399.     CallError(stacktop,"dynamic-set: non-symbolic reference",id,NONCONTINUABLE);
  400.  
  401.   if (!is_cons(forms)) 
  402.     CallError(stacktop,"dynamic-set: missing value form",forms,NONCONTINUABLE);
  403.  
  404.   form = CAR(forms); forms = CDR(forms);
  405.  
  406.   if (forms != nil)
  407.     CallError(stacktop,"dynamic-set: extraneous forms",forms,NONCONTINUABLE);
  408.  
  409.   STACK_TMP(id);
  410.   form = EUCALL_3(module_eval,mod,env,form);
  411.   UNSTACK_TMP(id);
  412.   walker = DYNAMIC_ENV();
  413.  
  414.   while (walker != NULL) {
  415.     if (walker->ENV.variable == id) return((walker->ENV.value = form));
  416.     walker = walker->ENV.next;
  417.   }
  418.  
  419.   if (id->SYMBOL.gvalue == NULL) {
  420.     print_string(stacktop,StdErr(),"****Illegal assignment to undeclared variable: ");
  421.     EUCALL_2(Fn_print,id,StdErr());
  422.     print_string(stacktop,StdErr(),"****Implicit defvar used\n");
  423.   }
  424.  
  425.   return((id->SYMBOL.gvalue = form));
  426. }
  427. EUFUN_CLOSE
  428.  
  429. LispObject special_dynamic_let;
  430. EUFUN_3( Sf_dynamic_let, mod, env, forms)
  431. {
  432.   LispObject bindings;
  433.   LispObject save;
  434.  
  435.   if (!is_cons(forms))
  436.     CallError(stacktop,"dynamic-let: null forms",forms,NONCONTINUABLE);
  437.  
  438.   bindings = CAR(forms); forms = CDR(forms);
  439.  
  440.   if (!is_cons(bindings)) 
  441.     CallError(stacktop,
  442.           "dynamic-let: invalid binding forms",bindings,NONCONTINUABLE);
  443.  
  444.   save = DYNAMIC_ENV(); /* Hang on for exit... */
  445.   
  446.   STACK_TMP(save);
  447.   STACK_TMP(forms); 
  448.   while (is_cons(bindings)) {
  449.     LispObject id,val,bind;
  450.     LispObject xx;
  451.  
  452.     bind = CAR(bindings);
  453.     STACK_TMP(CDR(bindings));
  454.     if (!is_cons(bind))
  455.       CallError(stacktop,
  456.         "dynamic-let: weird binding",bindings,NONCONTINUABLE);
  457.  
  458.     id = CAR(bind); bind = CDR(bind);
  459.  
  460.     if (!is_symbol(id)) 
  461.       CallError(stacktop,"dynamic-let: non-symbolic var",id,NONCONTINUABLE);
  462.  
  463.     if (!is_cons(bind))
  464.       CallError(stacktop,"dynamic-let: weird binding",bindings,NONCONTINUABLE);
  465.  
  466.     val = CAR(bind);
  467.  
  468.     STACK_TMP(id);
  469.     val = EUCALL_3(module_eval,ARG_0(stackbase),ARG_1(stackbase),val);
  470.     UNSTACK_TMP(id);
  471.  
  472.     xx = allocate_env(stacktop,id,val,
  473.               ((LispObject)(DYNAMIC_ENV())));
  474.     DYNAMIC_ENV()=xx;
  475.     UNSTACK_TMP(bindings);
  476.   }
  477.   UNSTACK_TMP(forms);
  478.   /* Do body... */
  479.   forms = EUCALL_3(Sf_progn,ARG_0(stackbase),ARG_1(stackbase),forms);
  480.   UNSTACK_TMP(save);
  481.   
  482.   DYNAMIC_ENV() = save; /* Repoint */
  483.  
  484.   return(forms);
  485. }
  486. EUFUN_CLOSE    
  487.  
  488. EUFUN_1( Fn_dynamic, form)
  489. {
  490.   {
  491.     LispObject ee = DYNAMIC_ENV();
  492.     while (ee!=NULL) {
  493.       if (ee->ENV.variable == form) return ee->ENV.value;
  494.       ee = ee->ENV.next;
  495.     }
  496.   }
  497.   {
  498.     LispObject ans;
  499.     ans =  (form->SYMBOL).gvalue;
  500.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  501.       ans = CallError(stacktop,"Unset dynamic variable ",form,CONTINUABLE);
  502.       (form->SYMBOL).gvalue = ans;
  503.     }
  504.     return ans;
  505.   }
  506. }
  507. EUFUN_CLOSE
  508.  
  509. LispObject special_dynamic;
  510. EUFUN_3( Sf_dynamic, mod, env, form)
  511. {
  512.   IGNORE(mod); IGNORE(env);
  513.  
  514.   while (!is_symbol(CAR(form)) || CDR(form)!=nil)
  515.     form = CallError(stacktop,"dynamic: Illegal dynamic form ",form,CONTINUABLE);
  516.  
  517.   form = CAR(form);
  518.  
  519.   {
  520.     LispObject ee = DYNAMIC_ENV();
  521.     while (ee!=NULL) {
  522.       if (ee->ENV.variable == form) return ee->ENV.value;
  523.       ee = ee->ENV.next;
  524.     }
  525.   }
  526.   {
  527.     LispObject ans;
  528.     ans =  (form->SYMBOL).gvalue;
  529.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  530.       ans = CallError(stacktop,"dynamic: unset dynamic variable ",form,CONTINUABLE);
  531.       (form->SYMBOL).gvalue = ans;
  532.     }
  533.     return ans;
  534.   }
  535. }
  536. EUFUN_CLOSE
  537.  
  538. LispObject special_quote;
  539. EUFUN_3( Sf_quote, mod, env, forms)
  540. {
  541.   IGNORE(mod); IGNORE(env);
  542.  
  543.   if (!is_cons(forms))
  544.     CallError(stacktop,"quote: bad forms",forms,NONCONTINUABLE);
  545.  
  546.   return(CAR(forms));
  547. }
  548. EUFUN_CLOSE
  549.  
  550. /*
  551.  
  552.  * Handlers...
  553.  
  554.  */
  555.  
  556. /* Hack... */
  557.  
  558. LispObject special_evalcm;
  559. EUFUN_3(Sf_evalcm, mod, env, form)
  560. {
  561.   LispObject ans;
  562.  
  563.   if (!is_cons(form))
  564.     CallError(stacktop,"eval/cm: no arguments",form,NONCONTINUABLE);
  565.  
  566.   if (is_cons(CDR(form)))
  567.     CallError(stacktop,"eval/cm: too many arguments",form,NONCONTINUABLE);
  568.  
  569.   form = EUCALL_3(module_eval,mod,env,form);
  570.  
  571.   ans = EUCALL_2(process_top_level_form,mod,CAR(form));
  572.  
  573.   return(ans);
  574. }
  575. EUFUN_CLOSE
  576.  
  577. /* Tag Body... */
  578.  
  579. /*
  580.  
  581.  * 'tagbody'
  582.  *
  583.  *   Plan: Do a naive walk on the body to extract a table of symbols with
  584.  *         following code, rig a continuation for 'go' statements to jump
  585.  *         to and run them in sequence until done...
  586.  
  587.  */
  588.  
  589. /* ******************** This function cannot be called *************** */
  590. static LispObject tagbody_before_label(LispObject *stacktop,LispObject body)
  591. {
  592.   if (!is_cons(body)) return(nil);
  593.   if (is_symbol(CAR(body))) return(nil);
  594.  
  595.   return(EUCALL_2(Fn_cons,CAR(body),tagbody_before_label(stacktop,CDR(body))));
  596. }
  597.  
  598. static LispObject tagbody_suck_symbols(LispObject *stacktop,LispObject body)
  599. {      
  600.   LispObject xx;
  601.   if (!is_cons(body)) return(nil);
  602.   if (is_symbol(CAR(body))) return(tagbody_suck_symbols(stacktop,CDR(body)));
  603.  
  604.   STACK_TMP(body);
  605.   xx=tagbody_suck_symbols(stacktop,CDR(body));
  606.   UNSTACK_TMP(body);
  607.   return(EUCALL_2(Fn_cons,CAR(body),xx));
  608. }
  609.  
  610. static LispObject tagbody_handle;
  611.  
  612. LispObject special_tagbody;
  613. EUFUN_3( Sf_tagbody, mod, env, forms)
  614. {
  615.   LispObject table,cont;
  616.   LispObject walker;
  617.   LispObject before;
  618.   LispObject res;
  619.  
  620.   table = (LispObject) EUCALL_1(make_table,NULL);
  621.   STACK_TMP(table);
  622.   before = nil;
  623.   before = tagbody_suck_symbols(stacktop,ARG_2(stackbase));
  624.   UNSTACK_TMP(table);
  625.   
  626.   walker = ARG_2(stackbase) /*forms*/;
  627.   while (is_cons(walker)) {
  628.     if (is_symbol(CAR(walker))) break;
  629.     walker = CDR(walker);
  630.   }
  631.  
  632.   if (is_cons(walker)) 
  633.     {
  634.       LispObject augenv;
  635.       LispObject runbody;
  636.  
  637.       /* Non-trivial label forms... */
  638.       stacktop+=2;
  639.       ARG_2(stackbase)=before;    /* kill forms*/
  640.       *(stackbase+3)=table;
  641.       *(stackbase+4)=nil;
  642.       STACK_TMP(walker);
  643.       cont = allocate_continue(stacktop);
  644.       *(stackbase+4)=cont;
  645.       
  646.       UNSTACK_TMP(walker);
  647.       do {
  648.     LispObject label, body;
  649.     label = CAR(walker); walker = CDR(walker);
  650.     STACK_TMP(walker);
  651.     STACK_TMP(label);
  652.     body = tagbody_suck_symbols(stacktop,walker);
  653.     UNSTACK_TMP(label);
  654.     EUCALL_3(Fn_table_ref_setter,*(stackbase+3)/*table*/,label,body);
  655.     UNSTACK_TMP(walker);
  656.  
  657.     while (is_cons(walker))
  658.       {
  659.         if (is_symbol(CAR(walker))) break;
  660.         walker = CDR(walker);
  661.       }
  662.       } while (is_cons(walker));
  663.  
  664.       /* Construct the augmented environment... */
  665.  
  666.       augenv = allocate_env(stacktop,tagbody_handle,*(stackbase+4)/*cont*/,ARG_1(stackbase));
  667.       ARG_1(stackbase)=augenv;
  668.  
  669.       runbody = ARG_2(stackbase)/*before*/;
  670.  
  671.       STACK_TMP(augenv);
  672.     reset:
  673.  
  674.       /* Go continuation... */
  675.  
  676.       if (set_continue(stacktop,*(stackbase+4)/*cont*/)) {
  677.     
  678.     /* Go has been called... */
  679.     
  680.     runbody = EUCALL_2(Fn_table_ref,*(stackbase+3)/*table*/,(*(stackbase+4))/*cont*/->CONTINUE.value);
  681.     
  682.     if (runbody == nil)
  683.       CallError(stacktop,
  684.             "go: no such label",cont->CONTINUE.value,NONCONTINUABLE);
  685.     goto reset;
  686.       }
  687.     
  688.       res = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,(LispObject)ARG_1(stackbase)/*augenv*/,runbody);
  689.       unset_continue((*(stackbase+4)));
  690.  
  691.       return(res);
  692.     }
  693.   else
  694.     {    /* The easy way... */
  695.       res = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,before);
  696.       return(res);
  697.     }
  698. }
  699. EUFUN_CLOSE
  700.  
  701. LispObject special_go;
  702. EUFUN_3( Sf_go, mod, env, forms)
  703. {
  704.   LispObject tag;
  705.   LispObject walker;
  706.  
  707.   IGNORE(mod);
  708.  
  709.   if (!is_cons(forms))
  710.     CallError(stacktop,"go: no tag",forms,NONCONTINUABLE);
  711.  
  712.   tag = CAR(forms);
  713.  
  714.   if (!is_symbol(tag))
  715.     CallError(stacktop,"go: non-symbolic tag",tag,NONCONTINUABLE);
  716.  
  717.   walker = env;
  718.   while (walker != NULL) {
  719.     if (walker->ENV.variable == tagbody_handle)
  720.       call_continue(stacktop,walker->ENV.value,tag);
  721.     walker = walker->ENV.next;
  722.   }
  723.  
  724.   CallError(stacktop,"go: not within tagbody",nil,NONCONTINUABLE);
  725.  
  726.   return(nil);
  727. }
  728. EUFUN_CLOSE
  729.  
  730. void initialise_specials(LispObject *stacktop)
  731. {
  732.   special_table = (LispObject) EUCALL_1(make_table,NULL);
  733.   add_root(&special_table);
  734.   
  735.   special_lambda = my_make_special(stacktop,"lambda",Sf_lambda);
  736.   add_root(&special_lambda);
  737.   special_macro_lambda = my_make_special(stacktop,"macro-lambda",Sf_mlambda);
  738.   add_root(&special_macro_lambda);
  739.   special_setq   = my_make_special(stacktop,"setq",Sf_setq);
  740.   add_root(&special_setq);
  741.   special_progn  = my_make_special(stacktop,"progn",Sf_progn);
  742.   add_root(&special_progn);
  743.   special_if     = my_make_special(stacktop,"if",Sf_if);
  744.   add_root(&special_if);
  745.   
  746. /*  last_continue = nil;*/
  747.  
  748.   special_dynamic_setq = my_make_special(stacktop,"dynamic-setq",Sf_dynamic_setq);
  749.   add_root(&special_dynamic_setq);
  750.   special_dynamic_set  = my_make_special(stacktop,"dynamic-set",Sf_dynamic_set);
  751.   add_root(&special_dynamic_set);
  752.   special_dynamic_let  = my_make_special(stacktop,"dynamic-let",Sf_dynamic_let);
  753.   add_root(&special_dynamic_let);
  754.   special_dynamic      = my_make_special(stacktop,"dynamic",Sf_dynamic);
  755.   add_root(&special_dynamic_let);
  756.   
  757.   special_quote = my_make_special(stacktop,"quote",Sf_quote);
  758.   add_root(&special_quote);
  759.   
  760.   special_tagbody = my_make_special(stacktop,"tagbody",Sf_tagbody);
  761.   add_root(&special_tagbody);
  762.   tagbody_handle = get_symbol(stacktop,"***tagbody-handle***");
  763.   add_root(&tagbody_handle);
  764.   special_go = my_make_special(stacktop,"go",Sf_go);
  765.   add_root(&special_go);
  766. }
  767.  
  768.